home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Yerk 3.6.7 / yerk 367 / System source / Args < prev    next >
Text File  |  1986-10-04  |  7KB  |  213 lines
  1. \ args - non-class support for named input parms, local variables
  2. \  6/28/85  cbd Dispose> named parms works correctly
  3. \  7/03/85  cbd Clear parmList in Pfind if interpreting
  4. \  9/24/85  cbd Hooks for floating point named args
  5. \  9/16/86  cdn Fixed dispose> to work for MM blocks as well as heap objects
  6.  
  7. 0 value  inParms    \ # named input parameters
  8. 0 value  locFlg        \ true=looking for local var tokens
  9. 0 value  fltMask    \ bit on for each float parm
  10. 6 constant maxParms
  11.  
  12. \ stub for floating point pick words - patched by float package
  13. : fstub  cr ?error 167 ;    \ Floating Point not installed
  14.  
  15. \ tables of pick and store cfas
  16. 6 'cfas  mp5 mp4 mp3 mp2 mp1 mp0
  17.  variable mpicks , , , , ,
  18. 6 'cfas  ms5 ms4 ms3 ms2 ms1 ms0
  19.  variable mputs  , , , , ,
  20. 6 'cfas  fstub fstub fstub fstub fstub fstub    \ cbd  9/85  float support
  21.  variable fpicks , , , , ,
  22.  
  23. \ ( ind addr -- elem )  fetch an element from mpicks, mputs
  24. : @mp  swap 4* + @  ;
  25.  
  26. \ define an mcfa structure for 8-byte lists. This will hold
  27. \ the symbol table of input parm names during compilation of a word.
  28.  
  29. 3 Codefields  2 Prefix init8  1 prefix  ++8
  30.  
  31. \ 2cfa clears the list
  32.     ' init8 Do.. 0 swap w! ..End
  33.  
  34. \ ( dElem -- )  1cfa adds double element to list
  35.     ' ++8    Do.. >R R w@ R 2+ w@ >= ?error 110
  36.         R w@  1 R w+!    \ get current ind, incr by 1
  37.         8 * 4+ R> +  2!  ..End    \ calc addr of element and store
  38.  
  39. \ ( dElem -- ind t OR f )  Search for element in list
  40.             Do.. Pushm  0 rot rot copyM W@ 0    \ For current size, DO
  41.         DO I 8 * 4+ Copym + 2@ 2over D=    \ compare to this element
  42.             IF  2drop drop I 1 1 1 Leave THEN
  43.         LOOP  2drop Dropm ..End    \ could have used named parms here!!
  44.  
  45. \ define the builder for  8-byte lists
  46. : List8  Build  0 w,  dup w,    \ current size, max size
  47.     8 * reserve ..End
  48.  
  49. maxParms  list8 ParmList
  50.  
  51. \ Pad for WORD format string    Len|xxxxxxxxxx
  52. \ ( addr n -- )  Pad a string with blanks to n chars
  53. : PadBL
  54.     swap >R dup R c@ - dup 0>
  55.     IF  R c@ R + 1+ swap blanks
  56.     ELSE drop THEN R> c! ;    \ Update length byte
  57.  
  58. \ ( addr -- )  Copy the string at addr to Pad+1
  59. : ToPad  dup c@  Pad 1+ swap 1+ cmove  ;
  60.  
  61. \ ( -- char )  Get the first chart of the word at Here
  62. : firstChr    Here 1+ c@  ;
  63.  
  64. Forward LocalFloat
  65.  
  66. \ Begin a stack descriptor, reading parameters until }
  67. \ format:  : wordName { in1 in2 in3 \ loc1 loc2 loc3 -- out1 out2}
  68. \ ( -- )
  69. : {    ?Comp init8 ParmList 0 put fltMask
  70.     0 put inparms    0 put locFlg    \ ADDPARMS
  71.     BEGIN   BL word    \ Add parms or vars to parmlist
  72.         firstChr ascii - <>    \ look for --
  73.     WHILE   firstChr ascii \ =
  74.         IF  true put locFlg
  75.         ELSE   firstChr ascii } =
  76.             ?error 111
  77.             locFlg 0=    \ ADDPNAME - Add parm name at Here to list
  78.             IF inParms  1+ put inparms THEN    \ bump # input parms
  79.             firstChr ascii % =            \ float parm?
  80.             IF  1 ' Parmlist 8+ w@ <<  fltMask or put fltMask  THEN
  81.             Here ToPad   Pad 1+    8 PadBL
  82.             Pad 2+  2@  ++8 ParmList
  83.         THEN
  84.     REPEAT
  85.     ' Parmlist 8+ w@ -dup    \ get current size
  86.     IF  inParms - 4 << inParms or c, fltMask c,
  87.         CState   0= IF  'code  colP here 6 - ! THEN
  88.     THEN
  89.     BEGIN  BL word  firstChr 0= ?error 112
  90.         firstChr ascii } =    \ eat characters until }
  91.     UNTIL
  92.     fltMask inparms >> IF Compile LocalFloat THEN
  93. ; Immediate
  94.  
  95. \ ( addr -- ind t OR f )  Look up string in ParmList
  96. : (PFind)   ToPad  Pad 1+ 8 PadBl
  97.     Pad 2+  2@  ParmList  dup    \ look for this element
  98.     IF   pad 2+ c@ ascii % =
  99.         IF  swap 6 + swap THEN
  100.     THEN ;    \  cbd 9/85 float arg
  101.  
  102. \ -Find will call Pfind to attempt to find a name first
  103. \ ( -- f  OR  mpickPfa 0  t )
  104. : Pfind
  105.     State 0=
  106.     IF init8 parmList 0    \ cbd 7/03/85
  107.     ELSE  Here (Pfind)
  108.         IF  dup 6 <
  109.             IF  MPicks @mp  4+  0 1
  110.             ELSE 6 - fpicks @mp  4+ 0 1
  111.             THEN
  112.         ELSE  0 THEN
  113.     THEN ;
  114.  
  115. \ return the type of a token for prefix. An index of 0-5
  116. \ indicates a named parm, and a Forth word returns its cfa.
  117. \ ( -- cfa type )
  118. : prfToken  @word (pfind)
  119.     IF dup
  120.     ELSE  here latest (find) 0= ?error 113
  121.         drop cfa dup @
  122.     THEN  ;
  123.  
  124. 'code vmodel constant vectCode
  125. 'code keyvec constant svcode
  126. 'code in     constant valCode
  127. 0 value modCode
  128. 0 value fvalCode        \ float package must patch
  129.  
  130. 'c fstub value farg!    \ float  cbd  9/85
  131. 'c fstub value farg++    \ float  cbd  9/85
  132. 'c fstub value fKill
  133.  
  134. \ compile a cfa if in compile state, else exec it.
  135. : ,exec  state IF , ELSE execute THEN ;
  136.  
  137. \ the following prefix compilers detect whether their subject is
  138. \ a Value, Vect  or named parm, which allows them to operate
  139. \ on all types of variables.
  140. \ ( val -- )  Store stack value in named parm location
  141. : ->   prfToken
  142.     CASE
  143.         0 5        RANGEOF ?comp Mputs @mp , ENDOF
  144.         6 11       RANGEOF ?comp farg! , 6 - 4* 8+ w,  ENDOF    \ float arg
  145.         vectCode   OF  8+  ,exec ENDOF    \ compile 2cfa for store
  146.         svCode     OF  8+  ,exec ENDOF
  147.         valCode    OF  8+  ,exec ENDOF
  148.         fvalCode   OF  8+  ,exec ENDOF    \ cbd 9/85
  149.         ?error 114
  150.     ENDCASE  ;  Immediate
  151.  
  152. \ the following build a named parm ref by compiling the cfa of the
  153. \ runtime word followed by a word containing the offset of the
  154. \ named parm from the top of the mStack
  155.  
  156. \ ( val -- )  increment a named parm
  157. : ++>   prfToken
  158.     CASE
  159.         0 5        RANGEOF  Compile (++>)  4* 8+ w,     ENDOF
  160.         6 11       RANGEOF ?comp farg++ , 6 - 4* 8+ w,  ENDOF    \ float arg
  161.         valCode    OF  4+ ,exec ENDOF
  162.         fvalCode   OF  4+ ,exec ENDOF    \ cbd  9/85  float arg
  163.         ?error 114
  164.     ENDCASE  ;  Immediate
  165.  
  166. \ ( -- )  execute a procedural argument or variable
  167. : Exec>  prfToken
  168.     CASE
  169.         0 5        RANGEOF Compile  (ex>)  4* 8+ w,  ENDOF
  170.         vectCode   OF  ,exec  ENDOF    \ compile 0cfa for execute
  171.         svCode     OF  ,exec  ENDOF
  172.         valCode    OF  ,exec  'c execute ,exec  ENDOF
  173.         ?error 114
  174.     ENDCASE  ;  Immediate
  175.  
  176. Forward ?isObj    \ defined in Class
  177.  
  178. \ ( addr -- )  release block and 0 its vector
  179. : Dispose  dup @ -dup
  180.     IF    ?isObj IF cfa THEN    \ is a heap object
  181.         killPtr
  182.     THEN 0 swap ! ;
  183.  
  184. \ dispose> operation for value & method stack referenced data
  185. : (disp)  R @  R> 4+ >R  dispose ;
  186. : (mdisp) R w@ R> 2+ >R  2+ 4* mp@ + dispose ;
  187.  
  188. : Dispose>   prfToken
  189.     CASE
  190.         0 5      RANGEOF  ?comp Compile (mdisp) w,        ENDOF
  191.         valCode  OF   Compile (disp)  dup @ 2- W@ + ,    ENDOF
  192.         modCode  OF   8+ ,exec   ENDOF    \ module
  193.         ?error 114
  194.     ENDCASE  ; Immediate
  195.  
  196. \ redefine exit & semicolon to support floating point named args.  IF
  197. \ the word being compiled has float args, the second byte after the cfa
  198. \ will be non-0, containing the arg type bitmask. Dispose of args before exit.
  199. : exit   latest pfa cfa @ colCode =
  200.     IF  Compile ;s
  201.     ELSE  latest pfa 1+ c@ dup
  202.         IF  fKill , w, ELSE drop THEN
  203.         Compile (semip)
  204.     THEN  ;  Immediate
  205.  
  206. : ; ?csp  cState ?error 163            \ Use ;M to terminate methods
  207.     latest c@ $ df and latest c!    \ be sure any smudge is undone
  208.     [Compile] exit [Compile] <[ exit <[  Immediate
  209.  
  210. \ ' Pfind Cfa  ->  Ufind
  211.  
  212. <" Class
  213.